home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / textyl / psrc / textyl.pas.ad < prev    next >
Text File  |  1993-11-07  |  30KB  |  1,001 lines
  1.  * given unit-radius. Scale those points to fit the desired radius
  2.  *)
  3. procedure defineCircleCpts (rad : ScaledPts; centx, centy : ScaledPts;
  4.                 var CircleCpt : ControlPoints;
  5.                 var numpts : integer);
  6. const UnitRadius = 16777216; (* TWO24 scaledpts *)
  7. var ratio : real;
  8. begin
  9.   if (rad = 0) then
  10.     begin
  11.     complain (ERRBAD);
  12.     writeln(logfile,'Error in fig#',pgfigurenum:0,' on page ',currpagenum:0);
  13.     writeln(logfile,'Zero length radius for circle! Setting to 1 sp');
  14.     rad := 1;
  15.     end;
  16.   ratio := float(rad) / float(UnitRadius);
  17.   numpts := 16;
  18.   CircleCpt[1,1] := round (ratio * 16777216.00000) + centx;
  19.   CircleCpt[1,2] := 0 + centy; {round (ratio *      0.00000)}
  20.   CircleCpt[2,1] := round (ratio * 15500126.47492) + centx;
  21.   CircleCpt[2,2] := round (ratio * 6420362.60441) + centy;
  22.   CircleCpt[3,1] := round (ratio * 11863283.20303) + centx;
  23.   CircleCpt[3,2] := round (ratio * 11863283.20303) + centy;
  24.   CircleCpt[4,1] := round (ratio * 6420362.60441) + centx;
  25.   CircleCpt[4,2] := round (ratio * 15500126.47492) + centy;
  26.   CircleCpt[5,1] := 0 + centx; {round (ratio *     -0.00000) }
  27.   CircleCpt[5,2] := round (ratio * 16777216.00000) + centy;
  28.   CircleCpt[6,1] := round (ratio * -6420362.60441) + centx;
  29.   CircleCpt[6,2] := round (ratio * 15500126.47492) + centy;
  30.   CircleCpt[7,1] := round (ratio * -11863283.20303) + centx;
  31.   CircleCpt[7,2] := round (ratio * 11863283.20303) + centy;
  32.   CircleCpt[8,1] := round (ratio * -15500126.47492) + centx;
  33.   CircleCpt[8,2] := round (ratio * 6420362.60441) + centy;
  34.   CircleCpt[9,1] := round (ratio * -16777216.00000) + centx;
  35.   CircleCpt[9,2] := 0 + centy; {round (ratio *     -0.00000)}
  36.   CircleCpt[10,1] := round (ratio * -15500126.47492) + centx;
  37.   CircleCpt[10,2] := round (ratio * -6420362.60441) + centy;
  38.   CircleCpt[11,1] := round (ratio * -11863283.20303) + centx;
  39.   CircleCpt[11,2] := round (ratio * -11863283.20303) + centy;
  40.   CircleCpt[12,1] := round (ratio * -6420362.60441) + centx;
  41.   CircleCpt[12,2] := round (ratio * -15500126.47492) + centy;
  42.   CircleCpt[13,1] := 0 + centx; {round (ratio *      0.00000) }
  43.   CircleCpt[13,2] := round (ratio * -16777216.00000) + centy;
  44.   CircleCpt[14,1] := round (ratio * 6420362.60441) + centx;
  45.   CircleCpt[14,2] := round (ratio * -15500126.47492) + centy;
  46.   CircleCpt[15,1] := round (ratio * 11863283.20303) + centx;
  47.   CircleCpt[15,2] := round (ratio * -11863283.20303) + centy;
  48.   CircleCpt[16,1] := round (ratio * 15500126.47492) + centx;
  49.   CircleCpt[16,2] := round (ratio * -6420362.60441) + centy;
  50.  (*   create the pre-list phantom *)
  51.   CircleCpt[0,1] := CircleCpt[16,1];
  52.   CircleCpt[0,2] := CircleCpt[16,2];  
  53. end;
  54.  
  55.  
  56. {---------------------------------------------------------------}
  57. (* compute control points for an arc going from startangle to 
  58.  * stopangle, centered at (centx, centy)
  59.  *)
  60. procedure definearcpts (rad : ScaledPts; centx, centy : ScaledPts;
  61.             startang, stopang : integer;
  62.             var cpts : ControlPoints;
  63.             var nknots : integer);
  64. var n : integer;
  65.     a, b, curr, delta: real;
  66.     i : integer;
  67. begin
  68.   a := startang * DEGTORAD;
  69.   b := stopang * DEGTORAD;
  70.   n := 16;
  71.  
  72.   if (a > b) then
  73.    begin
  74.     a := a - (2 * PI);
  75.    end;
  76.  
  77.   delta := abs(b - a) / n;
  78.  
  79.   if (a = b) then
  80.    begin
  81.    complain (ERRNOTBAD);
  82.    writeln(logfile,'Error in compute arc points:: should be a circle');
  83.    end;
  84.  curr := a;
  85.  i := 1;
  86.  while ((curr <= b)) do
  87.    begin     (* make arc about (centx,centy) *)
  88.    cpts[i,1] := round (rad * cos (curr)) + centx;
  89.    cpts[i,2] := round (rad * sin (curr)) + centy;
  90.    i := i + 1;
  91.    curr := curr + delta;
  92.    end;  (* while *)
  93.  
  94. (* go one point beyond --
  95.  *  around the arc so that we can have good smoothness
  96.  *  for this phantom point 
  97.  *)
  98.  
  99.  cpts[i,1] := round (rad * cos (b + delta)) + centx;
  100.  cpts[i,2] := round (rad * sin (b + delta)) + centy;
  101.  
  102. (* and one phantom point before the list *)
  103.  cpts[0,1] := round (rad * cos (a - delta)) + centx;
  104.  cpts[0,2] := round (rad * sin (a - delta)) + centy;
  105.  
  106.  
  107.  nknots := i-1;
  108. end; 
  109.               
  110.   
  111.  
  112. (* &&Module spline.p *)
  113. (*
  114.  Procedures below may make free use of the global variables
  115.         arrayXY   [list of control points]
  116.         pointmatrix [list of spline segments]
  117.         knot    [list of spline knots]
  118.         catrommtx  [matrix for Catmull-Rom splines]
  119.         bsplmtx   [matrix for B-splines]
  120.         lastPoint, intervals
  121. *)
  122.  
  123.  
  124. {-----------------------------------------------------}
  125. function max (a, b: integer):integer;
  126. begin
  127.   if (a > b) then
  128.     max := a
  129.   else
  130.     max := b;
  131. end;
  132.  
  133. {-----------------------------------------------------}
  134. function min (a, b: integer):integer;
  135. begin
  136.   if (a < b) then
  137.     min := a
  138.   else
  139.     min := b;
  140. end;
  141.  
  142. {---------------------------------------------------------------------}
  143. (* initialize the Catmull-Rom basis matrix *)
  144.  
  145. procedure initcrmatrix;
  146. begin
  147.   catrommtx[1,1] := -0.5; catrommtx[1,2] := 1.5;
  148.   catrommtx[1,3] := -1.5; catrommtx[1,4] := 0.5;
  149.   catrommtx[2,1] := 1.0;  catrommtx[2,2] := -2.5;
  150.   catrommtx[2,3] := 2.0;  catrommtx[2,4] := -0.5;
  151.   catrommtx[3,1] := -0.5; catrommtx[3,2] := 0.0;
  152.   catrommtx[3,3] := 0.5;  catrommtx[3,4] := 0.0;
  153.   catrommtx[4,1] := 0.0;  catrommtx[4,2] := 1.0;
  154.   catrommtx[4,3] := 0.0;  catrommtx[4,4] := 0.0;
  155. end;
  156.  
  157. {-----------------------------------------------------}
  158. procedure initbsplmatrix;
  159. begin
  160.   bsplmtx[1,1] := -1.0/6.0;     bsplmtx[1,2] := 0.5;
  161.   bsplmtx[1,3] := -0.5;         bsplmtx[1,4] := 1.0/6.0;
  162.   bsplmtx[2,1] := 0.5;          bsplmtx[2,2] := -1.0;
  163.   bsplmtx[2,3] := 0.5;          bsplmtx[2,4] := 0.0;
  164.   bsplmtx[3,1] := -0.5;         bsplmtx[3,2] := 0.0;
  165.   bsplmtx[3,3] := 0.5;          bsplmtx[3,4] := 0.0;
  166.   bsplmtx[4,1] := 1.0/6.0;      bsplmtx[4,2] := 2.0/3.0;
  167.   bsplmtx[4,3] := 1.0/6.0;      bsplmtx[4,4] := 0.0;
  168. end;
  169.  
  170. {--------------------------------------------------------}    
  171. (* init the Cardinal Spline Matrix *)
  172. procedure initcardmatrix;
  173. begin
  174.   cardmtx[1,1] := -1.0; cardmtx[1,2] := 1.0;
  175.   cardmtx[1,3] := -1.0; cardmtx[1,4] := 1.0;
  176.   cardmtx[2,1] := 2.0;  cardmtx[2,2] := -2.0;
  177.   cardmtx[2,3] := 1.0;  cardmtx[2,4] := -1.0;
  178.   cardmtx[3,1] := -1.0; cardmtx[3,2] := 0.0;
  179.   cardmtx[3,3] := 1.0;  cardmtx[3,4] := 0.0;
  180.   cardmtx[4,1] := 0.0;  cardmtx[4,2] := 1.0;
  181.   cardmtx[4,3] := 0.0;  cardmtx[4,4] := 0.0;
  182. end;
  183.  
  184. {--------------------------------------------------------}    
  185. procedure initallspline;
  186.   begin
  187.   initcrmatrix;
  188.   initbsplmatrix;
  189.   initcardmatrix;
  190.   end;
  191.  
  192.  
  193. {-----------------------------------------------------}
  194. procedure matXvector (var m: Fourby4Matrix; (* IN *)
  195.             var v: Oneby4Vector; (* IN *)
  196.                         var result: Oneby4Vector); (* OUT *)
  197. var t: Oneby4Vector;
  198. begin
  199.   t[1] := v[1]*m[1,1] + v[2]*m[1,2] + v[3]*m[1,3] + v[4]*m[1,4];
  200.   t[2] := v[1]*m[2,1] + v[2]*m[2,2] + v[3]*m[2,3] + v[4]*m[2,4];
  201.   t[3] := v[1]*m[3,1] + v[2]*m[3,2] + v[3]*m[3,3] + v[4]*m[3,4];
  202.   t[4] := v[1]*m[4,1] + v[2]*m[4,2] + v[3]*m[4,3] + v[4]*m[4,4];
  203.   result[1] := t[1]; result[2] := t[2];
  204.   result[3] := t[3]; result[4] := t[4];
  205. end;
  206.  
  207. {-----------------------------------------------------}
  208. (* actually the dot-product *)
  209. function vecXvec (var v1, v2: Oneby4Vector) : real;
  210. begin
  211.   vecXvec := v1[1]*v2[1] + v1[2]*v2[2] + v1[3]*v2[3] + v1[4]*v2[4];
  212. end;
  213.  
  214.  
  215. {------------------------------------------------------}
  216. (* basXctl is the pre-computed BasisMatrix times the control-point vector *)
  217.  
  218. function splinePosition (var basXctl : Oneby4Vector; (* IN *)
  219.             t : real ) : real;
  220. var tvect : Oneby4Vector;    { vector of t values for spline matrix}
  221. begin
  222.   tvect[4] := 1.0;
  223.   tvect[3] := t;
  224.   tvect[2] := t * t;
  225.   if (tvect[2] <= MINREAL) then
  226.     begin            (* avoid underflow problems *)
  227.     tvect[2] := 0.0;
  228.     end;
  229.   tvect[1] := t * tvect[2];  (* t^3 *)
  230.   splinePosition := vecXvec (tvect, basXctl);  
  231. end;  
  232.             
  233. {-------------------------------------------------}
  234. function TwoToThe (n : integer) : integer;
  235. label 78;
  236. var i : integer;
  237.     tmp : integer;
  238. begin
  239. tmp := 1;
  240. if (n <= 0) then
  241.   goto 78;
  242. if (n < 6) then
  243.   begin
  244.     case n of
  245.       1 : tmp := 2;
  246.       2 : tmp := 4;
  247.       3 : tmp := 8;
  248.       4 : tmp := 16;
  249.       5 : tmp := 32;
  250.     end; (* case *)
  251.   end  (* if *)
  252. else
  253.   begin
  254.   tmp := 32;
  255.   for i := 6 to n do
  256.    tmp := tmp * 2;
  257.   end;
  258. 78:
  259.   TwoToThe := tmp;
  260. end;  
  261.  
  262. {------------------------------------------------------}
  263. function distance (x0, y0, x1, y1 : real) : real;
  264. var res : real;
  265. begin
  266.   res := sqrt ( (x1 - x0)*(x1 - x0) + (y1 - y0)*(y1 - y0));
  267.   distance := res;
  268. end;  
  269.  
  270.  
  271. {------------------------------------------------------}
  272. (* compute the number of subdivisions for this span.
  273.    We do this by a quadrature method and a simple linear-distance
  274.    metric. This is not optimal in the number of subdivisions actually
  275.    required, but is computationally efficient and accurate to the 
  276.    nearest power of 2 .
  277.    *)
  278. function numsubdivisions (var XtimesBas, YtimesBas : Oneby4Vector;
  279.               resolution : ScaledPts): integer;
  280. var n : integer;
  281.     d : integer;  
  282.     t : real;
  283.     x0, y0, xt, yt : real;
  284. begin
  285.   x0 := splinePosition (XtimesBas, 0.0);
  286.   y0 := splinePosition (YtimesBas, 0.0);
  287.  
  288.   t := 1.0;
  289.   n := 0;
  290.   xt := splinePosition (XtimesBas, t);
  291.   yt := splinePosition (YtimesBas, t);  
  292.  
  293.   while ((round (distance (x0, y0, xt, yt)) > resolution) or
  294.        (n < 1)) do
  295.     begin
  296.     t := t / 2.0; (* perform the quadrature *)
  297.     n := n + 1;
  298.     xt := splinePosition (XtimesBas, t);
  299.     yt := splinePosition (YtimesBas, t);  
  300.     end;  (* while *)
  301.   numsubdivisions := TwoToThe (n);  
  302. end;  
  303.  
  304. {------------------------------------------------------------------------}
  305. (*  compute new control vertices such that the resulting spline
  306.  * will interpolate through the old control points.
  307.  * This will work as long as the actual arc length
  308.  * between consecutive nodes does not vary from span to span.
  309.  * The method is noted in Wu and Abel's CACM 20(10) Oct 77 paper 
  310.  * but the actual working method is from
  311.  *    Barsky and Greenberg's paper in
  312.  *    CG&IP 14(3) Nov 1980 pp.203-226
  313.  *)
  314. procedure invertsplvertices (numpts : integer; 
  315.                 isclosed : boolean;
  316.                 var xys : ControlPoints); (* INOUT *)
  317. var i : integer;
  318.     beta, Xrprime, Yrprime : array[0..MAXCTLPTS] of real;
  319.     tempxys : ControlPoints;
  320. begin
  321.     (* compute the values of beta *)
  322.   beta[1] := 0.25;
  323.   for i := 2 to numpts + 1 do
  324.     beta[i] := 1.0 / (4.0 - beta[i - 1]);
  325.  
  326.     (* and the r primes from the original vertices *)
  327.   Xrprime[1] := beta[1] * xys[1,1] * 5.0;
  328.   Yrprime[1] := beta[1] * xys[1,2] * 5.0;
  329.   for i := 2 to numpts -1 do
  330.     begin
  331.     Xrprime[i] := beta[i] * (6.0 * xys[i,1] - Xrprime[i - 1]);
  332.     Yrprime[i] := beta[i] * (6.0 * xys[i,2] - Yrprime[i - 1]);
  333.     end;  (* for *)
  334.   Xrprime[numpts] := beta[numpts] * (5.0 * xys[numpts,1] - Xrprime[numpts - 1]);
  335.   Yrprime[numpts] := beta[numpts] * (5.0 * xys[numpts,2] - Yrprime[numpts - 1]);
  336.  
  337. (* Now perform the back-substitution from the bottom up *)
  338.   tempxys[numpts,1] := round (Xrprime[numpts]);
  339.   tempxys[numpts,2] := round (Yrprime[numpts]);
  340.   for i := numpts - 1 downto 1 do
  341.     begin
  342.     tempxys[i,1] := round (Xrprime[i] - beta[i] * tempxys[i + 1, 1]);
  343.     tempxys[i,2] := round (Yrprime[i] - beta[i] * tempxys[i + 1, 2]);
  344.     end;
  345.  
  346. if (isclosed) then
  347.   begin
  348.  (* at this point, we've probably been through one control-point
  349.   *  adjustment, so let's not muck it up 
  350.   *)
  351.   tempxys[numpts+1,1] := tempxys[1,1];
  352.   tempxys[numpts+1,2] := tempxys[1,2];
  353.   tempxys[numpts+2,1] := tempxys[2,1];
  354.   tempxys[numpts+2,2] := tempxys[2,2];
  355.   tempxys[0,1] := tempxys[numpts,1];
  356.   tempxys[0,2] := tempxys[numpts,2];
  357.       (* copy them back *)
  358.   for i := 0 to (numpts+2) do
  359.     begin
  360.     xys[i,1] := tempxys[i,1];
  361.     xys[i,2] := tempxys[i,2];
  362.     end;  
  363.   end  (* closed *)
  364. else
  365.   begin
  366.   (* copy back *)
  367.   for i := 2 to numpts -1 do
  368.    begin
  369.     xys[i,1] := tempxys[i,1];
  370.     xys[i,2] := tempxys[i,2];
  371.    end;
  372.   end;  (* open*)
  373. end; 
  374.                   
  375.  
  376. {-----------------------------------------------------}
  377. (*  adjust the list of control points so that we can use
  378.  *   it for  B-spline interpolation.  
  379.  *  Add any "phantom" vertices necessary so that the end
  380.  *   conditions will be correct for interpolation
  381.  *)
  382. procedure Bctlptadjust (isclosed : boolean; isarc : boolean;
  383.              var n: integer; (* INOUT *)
  384.                          var xys: ControlPoints; (* INOUT *)
  385.                          var thx: ThickAryType); (* INOUT *)
  386. var j : integer;
  387.     tmp : ControlPoints;
  388.     tmpthx : ThickAryType;
  389. begin   (* ctlpt adjust*)
  390.  
  391. if (isclosed) then
  392.   begin
  393. (* here, we have to supply the last 'real' point for the user,
  394.    and add three phantoms-- one before, and two after *)
  395.  
  396.   if (n = 2) then
  397.     begin
  398.     complain (ERRBAD);
  399.     writeln(logfile,'A closed spline requires more than 2 control points ');
  400.     writeln(logfile,'making a temporary fix in order to continue...');
  401.     xys[3,1] := xys[1,1];
  402.     xys[3,2] := xys[1,2];
  403.     end;  
  404.  
  405.   for j := 1 to (n) do
  406.     begin
  407.     tmp[j, 1] := xys[j, 1];
  408.     tmp[j, 2] := xys[j, 2];
  409.     tmpthx[j] := thx[j];
  410.     end;
  411.         (* Now take care of the 'phantom' vertices *)    
  412.   tmp[n+1, 1] := xys[1, 1];
  413.   tmp[n+1, 2] := xys[1, 2];
  414.   tmpthx[n+1] := thx[1];
  415.   tmp[n+2, 1] := xys[2, 1];
  416.   tmp[n+2, 2] := xys[2, 2];
  417.   tmpthx[n+2] := thx[2];
  418.   tmp[n+3, 1] := xys[3, 1]; 
  419.   tmp[n+3, 2] := xys[3, 2];
  420.   tmpthx[n+3] := thx[3];
  421.  
  422.   if (not isarc) then
  423.     begin
  424.     tmp[0,1] := xys[n, 1]; (* wrap around to the real last point *)
  425.     tmp[0,2] := xys[n, 2];
  426.     tmpthx[0] := thx[n];
  427.     end
  428.   else
  429.     begin
  430.     tmp[0,1] := xys[0,1];
  431.     tmp[0,2] := xys[0,2];
  432.     tmpthx[0] := thx[0];
  433.     end;
  434.  
  435.   n := n + 1;     (* we supplied the 'last' point for the user *)
  436.  
  437.   for j := 0 to n+2 do
  438.     begin
  439.     xys[j,1] := tmp[j,1];
  440.     xys[j,2] := tmp[j,2];
  441.     thx[j] := tmpthx[j];
  442.     end;  (* for *)
  443.   end  (* if closed *)
  444. else 
  445.   begin         (* OPEN SPLINE *)
  446.   if (not isarc) then
  447.     begin
  448.     tmp[0,1] := 2 * xys[1, 1] - xys[2,1];
  449.     tmp[0,2] := 2 * xys[1, 2] - xys[2,2];
  450.     end
  451.   else
  452.     begin
  453.     tmp[0,1] := xys[0,1];
  454.     tmp[0,2] := xys[0,2];
  455.     end;
  456.   tmpthx[0] := thx[1];
  457.  
  458.   for j := 1 to (n) do
  459.     begin
  460.     tmp[j, 1] := xys[j, 1];
  461.     tmp[j, 2] := xys[j, 2];
  462.     tmpthx[j] := thx[j];
  463.     end;
  464.   
  465.   tmp[n+1, 1] := 2 * xys[n, 1] - xys[n-1,1];
  466.   tmp[n+1, 2] := 2 * xys[n, 2] - xys[n-1,2];
  467.   tmpthx[n+1] := thx[n];
  468.  
  469.   tmp[n+2, 1] := tmp[n+1, 1];
  470.   tmp[n+2, 2] := tmp[n+1, 2];
  471.   tmpthx[n+2] := thx[n];
  472.  
  473.   for j := 0 to n+2 do
  474.     begin
  475.     xys[j,1] := tmp[j,1];
  476.     xys[j,2] := tmp[j,2];
  477.     thx[j] := tmpthx[j];
  478.     end;  (* for *)
  479.   end; (*  if open *)
  480.   
  481. end;
  482.  
  483.  
  484.  
  485. {-----------------------------------------------------}
  486. (*  adjust the list of control points so that we can use
  487.  *       it for simple Catmull-Rom spline interpolation.  
  488.  *  Add any "phantom" vertices necessary so that the end
  489.  *   conditions will be correct for interpolation
  490.  *)
  491. procedure CRctlptadjust (isclosed : boolean; isarc : boolean;
  492.              var n: integer; (* INOUT *)
  493.                          var xys: ControlPoints; (* INOUT *)
  494.                          var thx: ThickAryType); (* INOUT *)
  495. var j : integer;
  496.     tmp : ControlPoints;
  497.     tmpthx : ThickAryType;
  498. begin   (* ctlpt adjust*)
  499. if (isclosed) then
  500.   begin
  501. (* here, we have to supply the last 'real' point for the user,
  502.    and add three phantoms-- one before, and two after *)
  503.  
  504.   if (n = 2) then
  505.     begin
  506.       complain (ERRBAD);
  507.       writeln(logfile,'A closed spline requires more than 2 control points ');
  508.       writeln(logfile,'making a temporary fix in order to continue...');
  509.       xys[3,1] := xys[1,1];
  510.       xys[3,2] := xys[1,2];
  511.     end;  
  512.  
  513.  
  514.   for j := 1 to (n) do
  515.     begin
  516.     tmp[j, 1] := xys[j, 1];
  517.     tmp[j, 2] := xys[j, 2];
  518.     tmpthx[j] := thx[j];
  519.     end;
  520.             (* the phantom vertices *)    
  521.     tmp[n+1, 1] := xys[1, 1];
  522.     tmp[n+1, 2] := xys[1, 2];
  523.     tmpthx[n+1] := thx[1];
  524.     tmp[n+2, 1] := xys[2, 1];
  525.     tmp[n+2, 2] := xys[2, 2];
  526.     tmpthx[n+2] := thx[2];
  527.     tmp[n+3, 1] := xys[3, 1];
  528.     tmp[n+3, 2] := xys[3, 2];
  529.     tmpthx[n+3] := thx[3];
  530.   
  531.     if (not isarc) then
  532.       begin
  533.       tmp[0,1] := xys[n, 1]; (* wrap around to the real last point *)
  534.       tmp[0,2] := xys[n, 2];
  535.       tmpthx[0] := thx[n];
  536.       end
  537.     else
  538.       begin
  539.       tmp[0,1] := xys[0,1];
  540.       tmp[0,2] := xys[0,2];
  541.       tmpthx[0] := thx[0];
  542.       end;
  543.     n := n + 1; (* we supplied the 'last' point for the user *)
  544.   
  545.     for j := 0 to n+2 do
  546.       begin
  547.       xys[j,1] := tmp[j,1];
  548.       xys[j,2] := tmp[j,2];
  549.       thx[j] := tmpthx[j];
  550.       end;  (* for *)
  551.   end  (* if closed *)
  552. else
  553.   begin (* OPEN SPLINE *)
  554.   if (not isarc) then
  555.     begin
  556.     tmp[0,1] := xys[1, 1]; (* double the first point *)
  557.     tmp[0,2] := xys[1, 2];
  558.     end
  559.   else
  560.     begin
  561.     tmp[0,1] := xys[0,1];
  562.     tmp[0,2] := xys[0,2];
  563.     end;  
  564.   tmpthx[0] := thx[1];
  565.  
  566.   for j := 1 to (n) do
  567.     begin
  568.     tmp[j, 1] := xys[j, 1];
  569.     tmp[j, 2] := xys[j, 2];
  570.     tmpthx[j] := thx[j];
  571.     end;
  572.     
  573.   tmp[n+1, 1] := xys[n, 1]; (* and triple the last *)
  574.   tmp[n+1, 2] := xys[n, 2];
  575.   tmpthx[n+1] := thx[n];
  576.   tmp[n+2, 1] := xys[n, 1];
  577.   tmp[n+2, 2] := xys[n, 2];
  578.   tmpthx[n+2] := thx[n];
  579.  
  580.   for j := 0 to n+2 do
  581.     begin
  582.     xys[j,1] := tmp[j,1];
  583.     xys[j,2] := tmp[j,2];
  584.     thx[j] := tmpthx[j];
  585.     end;  (* for *)
  586.   end; (* if open *)
  587. end;    (* ctlpt adjust *)
  588.  
  589.      
  590.  
  591. {----------------------------------------------------------}
  592.  
  593. procedure interpsplines (splinetype: SplineKind;
  594.              isclosed: boolean;
  595.              isanArc: boolean;
  596.              linepatt : LineStyle;
  597.                          var basismatrix : Fourby4Matrix; (* IN *)
  598.                          numctls: integer; 
  599.                          var arrayXY: ControlPoints; (* IN *)
  600.                          var pointmatrix: SplineSegments; (* OUT *)
  601.                          varythicks: boolean;
  602.                          var thickmatrix: ThickAryType; (* IN *)
  603.                          var TTmatrix: ThickAryType); (* OUT *)
  604. label 32;
  605. var xctl, yctl,        { vectors of x, y posits of control points}
  606.     wctl : Oneby4Vector; {vector of thicknesses at each ctl pt}
  607.     t, incr: real;
  608.     Pi: integer;    { P sub i }
  609.     i, currpt : integer;    
  610.     theresolution : ScaledPts;
  611.  
  612. begin (* interp splines*)
  613.   if ((not isclosed) and (isanArc)) then
  614.     numctls := numctls + 1; (* lie a little *)
  615.  
  616.    case (splinetype) of
  617.  
  618.      BSPL: Bctlptadjust (isclosed, isanArc, numctls, arrayXY, thickmatrix);
  619.      
  620.      CARD,
  621.      CATROM:  CRctlptadjust (isclosed, isanArc, numctls, arrayXY, thickmatrix);
  622.     
  623.      INTBSPL: begin
  624.              if (isclosed) then
  625.           begin
  626.           Bctlptadjust (true, isanArc, numctls, arrayXY, thickmatrix);
  627.           invertsplvertices (numctls, true, arrayXY);
  628.           end
  629.         else 
  630.           begin
  631.           invertsplvertices (numctls, false, arrayXY);
  632.           Bctlptadjust (false, isanArc, numctls, arrayXY, thickmatrix);
  633.           end;  (* else *)
  634.                end; (* Interpolating Bsplines *)
  635.    end;
  636.  
  637.   if ((not isclosed) and (isanArc)) then
  638.     numctls := numctls - 1; (* UN-lie a little *)
  639.  
  640.  
  641. (* this is the scheme:
  642.  *    val :=  t-vector   *  Basis matrix     * point matrix
  643.  *        [t^3  t^2 t 1] *      [[Ms]]       * [Pi-1 Pi Pi+1 Pi+2]
  644.  *    where "Pi-1" is "P sub (i-1)", etc.
  645.  *
  646.  *  But we do this in a round about way:
  647.  *        Point matrix * basis
  648.  *   then   * t-vector   will yield the single value
  649.  *   
  650.  *   there are certainly faster ways to do this, 
  651.  *   but this is the easiest to understand
  652.  *)
  653.  
  654.   currpt := 1;
  655.   case linepatt of
  656.      solid : theresolution := MAXVECLENsp;
  657.      dotted,
  658.      dashed,
  659.      dotdash : theresolution := 3 * MAXVECLENsp; {###}
  660.    end;
  661.  
  662.   for Pi := 1 to (numctls - 1) do
  663.     begin
  664.     xctl[1] := float(arrayXY[Pi-1, 1]);
  665.     xctl[2] := float(arrayXY[Pi,   1]);
  666.     xctl[3] := float(arrayXY[Pi+1, 1]);
  667.     xctl[4] := float(arrayXY[Pi+2, 1]);
  668.     yctl[1] := float(arrayXY[Pi-1, 2]);
  669.     yctl[2] := float(arrayXY[Pi,   2]);
  670.     yctl[3] := float(arrayXY[Pi+1, 2]);
  671.     yctl[4] := float(arrayXY[Pi+2, 2]);
  672.     matXvector (basismatrix, xctl, xctl);
  673.     matXvector (basismatrix, yctl, yctl);
  674.  
  675.     (* compute the delta-t increment for this segment
  676.         based on a metric for subdivision *)
  677.     intervals := numsubdivisions (xctl, yctl, theresolution);
  678.     if ((linepatt = solid) and (intervals <= 2)) then
  679.       intervals := intervals * 2;
  680.     incr := 1.0 / intervals;
  681.  
  682.     (* avoid over-flowing the "pointmatrix" *)
  683.     if ((currpt + intervals - 1) >= MAXSPLINESEGS) then
  684.        begin
  685.        complain (ERRREALBAD);
  686.        writeln (logfile,'error: Too many spline segments required.');
  687.        writeln (logfile,' Reducing the number of control points to get output.');
  688.        goto 32;
  689.        end;
  690.   
  691.     t := 0.0;
  692.     while (t < 0.999999999) do
  693.       begin
  694.     pointmatrix[currpt, 1] := round (splinePosition (xctl, t));
  695.     pointmatrix[currpt, 2] := round (splinePosition (yctl, t));
  696.  
  697.     if (varythicks) then
  698.       begin
  699.         wctl[1] := float(thickmatrix[Pi-1]);
  700.         wctl[2] := float(thickmatrix[Pi  ]);
  701.         wctl[3] := float(thickmatrix[Pi+1]);
  702.         wctl[4] := float(thickmatrix[Pi+2]);
  703.         matXvector (catrommtx, wctl, wctl);  (* requires using Catmull-Rom *)
  704.         TTmatrix[currpt] := round (splinePosition (wctl, t));
  705.       end;
  706.     
  707.         t := t + incr;
  708.         currpt := currpt + 1;
  709.       end; (* while loop *)
  710.  
  711.  
  712.     end; (* for loop *)
  713.  
  714. 32:
  715.     (* the END-condtion *)
  716.     pointmatrix[currpt, 1] := round (splinePosition (xctl, 1.0));
  717.     pointmatrix[currpt, 2] := round (splinePosition (yctl, 1.0));    
  718.     if (varythicks) then
  719.       begin
  720.     wctl[1] := thickmatrix[numctls-2];
  721.     wctl[2] := thickmatrix[numctls-1];
  722.     wctl[3] := thickmatrix[numctls];
  723.     wctl[4] := thickmatrix[numctls+1];
  724.     matXvector (catrommtx, wctl, wctl);  (* requires using Catmull-Rom *)
  725.     TTmatrix[currpt] := round (splinePosition (wctl, 1.0));
  726.       end;
  727.  
  728.     lastPoint := currpt;
  729.  
  730. end; (* interpsplines *)
  731.  
  732.  
  733. {----------------------------------------------------------------}
  734. procedure drawSpline (splinetype : SplineKind;
  735.              isclosed: boolean;
  736.              isanArc: boolean;
  737.              patt : LineStyle;
  738.                      numctls: integer;
  739.                      var arrayXY: ControlPoints; (* IN *)
  740.                      var pointmatrix: SplineSegments; (* OUT *)
  741.                      varythicks: boolean;
  742.                      var thickmatrix: ThickAryType; (* IN *)
  743.                      var TTmatrix: ThickAryType); (* OUT *)
  744. begin
  745.   lastPoint := 0;
  746.  
  747.  
  748.   case (splinetype) of
  749.     CATROM : interpsplines (splinetype, isclosed, isanArc, patt, catrommtx,
  750.                numctls, arrayXY, pointmatrix,
  751.                          varythicks, thickmatrix, TTmatrix);
  752.  
  753.     CARD : interpsplines (splinetype, isclosed, isanArc, patt, cardmtx, 
  754.                numctls, arrayXY, pointmatrix, 
  755.                        varythicks, thickmatrix, TTmatrix);
  756.  
  757.     BSPL : interpsplines (splinetype, isclosed, isanArc, patt, bsplmtx, 
  758.                numctls, arrayXY, pointmatrix, 
  759.                        varythicks, thickmatrix, TTmatrix);
  760.  
  761.     INTBSPL : interpsplines (splinetype, isclosed, isanArc, patt, bsplmtx,
  762.                numctls, arrayXY, pointmatrix, 
  763.                        varythicks, thickmatrix, TTmatrix);
  764.   end; (*Case *)                   
  765. end;
  766.  
  767.  
  768. (* &&module TeXtyl *)
  769. {----------------------------------------------------------------}
  770. (* rotate a (x,y) point about mx, my *)
  771. procedure ptrotate (var x, y : integer;
  772.                         mx, my: integer;
  773.                         angle : real);
  774. var tmpx, tmpy : integer;
  775.     cosa, sina : real;
  776. begin
  777.   tmpx := x - mx;       
  778.   tmpy := y - my;
  779.   cosa := cos(angle * DEGTORAD); 
  780.   sina := sin(angle * DEGTORAD);
  781.   x := round(tmpx * cosa - tmpy * sina) + mx;
  782.   y := round(tmpx * sina + tmpy * cosa) + my;
  783. end;
  784.  
  785. {----------------------------------------------------------------}
  786. (* transform two line points: scale, rotate and translate 
  787. *)
  788. procedure xfmlinepts (var x1, y1, x2, y2 : ScaledPts;
  789.                         offh, offv : ScaledPts;
  790.                         midx, midy : ScaledPts;
  791.                         scalefact : real;
  792.                         theta : real;
  793.                         dx, dy : ScaledPts;
  794.                         sx, sy : real);
  795. begin
  796.   if ((sx = 0.0) or (sy = 0.0)) then
  797.     begin
  798.       complain (ERRBAD);
  799.       writeln(logfile,'?? Some scale factor is Zero... continuing anyway');
  800.     end;
  801.         (* scale about center of item*)
  802.   if ((sx <> 1.0) or (sy <> 1.0)) then
  803.    begin
  804.    x1 := round((x1 - midx) * sx) + midx;
  805.    x2 := round((x2 - midx) * sx) + midx;
  806.    y1 := round((y1 - midy) * sy) + midy;     
  807.    y2 := round((y2 - midy) * sy) + midy;
  808.    end;
  809.       (* rotate if necessary *)
  810.    if (theta <> 0.0) then
  811.      begin  (* rotate about the midpoint *)
  812.      ptrotate(x1, y1, midx, midy, theta);
  813.      ptrotate(x2, y2, midx, midy, theta);
  814.      end;
  815.       (* translate *)
  816.    x1 := (x1 + round(dx * scalefact) + offh);
  817.    x2 := (x2 + round(dx * scalefact) + offh);
  818.    y1 := (y1 + round(dy * scalefact) + offv);
  819.    y2 := (y2 + round(dy * scalefact) + offv);
  820. end;  (* xfmlinepts *)
  821.  
  822. {----------------------------------------------------------------}
  823. procedure xfmcontpts (var xpts : ControlPoints; xknots : integer;
  824.                         offh, offv : ScaledPts; midx, midy : ScaledPts;
  825.                         scalefact : real;
  826.                         theta : real; dx, dy : ScaledPts; sx, sy : real);
  827. var i : integer;
  828. begin
  829.     (* scale about center of item *)
  830.  if ((sx <> 1.0) or (sy <> 1.0)) then
  831.   for i := 0 to xknots do
  832.      begin
  833.      xpts[i,1] := round((xpts[i,1] - midx) * sx) + midx;
  834.      xpts[i,2] := round((xpts[i,2] - midy) * sy) + midy;
  835.      end;
  836.  
  837.   if (theta <> 0.0) then
  838.     begin (* rotate about center *)
  839.     for i := 0 to xknots do
  840.       begin
  841.       ptrotate (xpts[i,1], xpts[i,2], midx, midy, theta);
  842.       end;
  843.     end;
  844.     (* translate *)
  845.   for i := 0 to xknots do
  846.     begin
  847.     xpts[i,1] := (xpts[i,1] + round(dx * scalefact) + offh);
  848.     xpts[i,2] := (xpts[i,2] + round(dy * scalefact) + offv);
  849.     end;
  850. end;  (* xfmcontpts *)
  851.  
  852.  
  853. {----------------------------------------------------------------}
  854. (* convert into DVI space and offset by H & V *)
  855. procedure dvilinepts (var x1, y1, x2, y2 : ScaledPts;
  856.             offh, offv : ScaledPts);
  857. begin
  858.    x1 := (x1  + offh);
  859.    x2 := (x2  + offh);
  860.    y1 := (y1 * (-1) + offv);
  861.    y2 := (y2 * (-1) + offv);
  862. end;
  863.  
  864. {----------------------------------------------------------------}
  865. (* convert into DVI space and offset by H & V *)
  866. procedure dvicontpts (var xpts : ControlPoints; xknots : integer;
  867.                         offh, offv : ScaledPts);
  868. var i : integer;
  869. begin
  870.   for i := 0 to xknots do
  871.     begin
  872.     xpts[i,1] := (xpts[i,1]  + offh);
  873.     xpts[i,2] := (xpts[i,2] * (-1) + offv);
  874.     end;
  875. end;
  876.  
  877. {----------------------------------------------------------------}
  878. (*    transform all the figure's elements according to the 
  879.     top-level tranformation requirements in 1st Quadrant space.
  880.     then reset the toplevel's xfms.
  881. *)
  882. procedure toplevelxfm (toplev, curfig : pItem; recurlevel : integer);
  883. var pi : pItem;
  884.     null1, null2 : ScaledPts;
  885.     old1, old2 : ScaledPts;
  886.     midx, midy : ScaledPts;
  887. begin
  888.   with toplev^ do
  889.     begin
  890.     midy := (BBty - BBby) div 2;
  891.     midx := (BBrx - BBlx) div 2;
  892.     end;
  893.   pi := curfig^.body^.things;  { if recur==0, this is same as toplev }
  894.   while (pi <> nil) do
  895.     begin
  896.     with pi^ do
  897.       begin
  898.       case (kind) of
  899.     Aline : begin
  900.         xfmlinepts (lx1, ly1, lx2, ly2, 0, 0, midx, midy, 1.0, 
  901.               toplev^.figtheta, toplev^.fdx, toplev^.fdy,
  902.               toplev^.fsx, toplev^.fsy);
  903.         end;
  904.     Aspline : begin
  905.           xfmcontpts (spts, nsplknots, 0, 0, midx, midy, 1.0,
  906.               toplev^.figtheta, toplev^.fdx, toplev^.fdy,
  907.               toplev^.fsx, toplev^.fsy);
  908.           end;
  909.     Attspline : begin
  910.           xfmcontpts (ttpts, nttknots, 0, 0, midx, midy, 1.0,
  911.               toplev^.figtheta, toplev^.fdx, toplev^.fdy,
  912.               toplev^.fsx, toplev^.fsy);
  913.             end;
  914.     Aarc : begin
  915.            null1 := 0; null2 := 0;
  916.            old1 := acentx; old2 := acenty;
  917.            xfmlinepts (acentx, acenty, null1, null2, 0,0, midx, midy, 1.0,
  918.             toplev^.figtheta, toplev^.fdx, toplev^.fdy,
  919.             toplev^.fsx, toplev^.fsy);        
  920.                   
  921.            xfmcontpts (arcpts, narcknots + 1, 0, 0, old1, old2, 1.0,
  922.               toplev^.figtheta, 
  923.               toplev^.fdx + (acentx - old1), 
  924.               toplev^.fdy + (acenty - old2),
  925.               toplev^.fsx, toplev^.fsy);
  926.            end;              
  927.     Alabel : begin
  928.          null1 := 0; null2 := 0;
  929.          xfmlinepts (labx, laby, null1, null2, 0, 0, midx, midy, 1.0,
  930.               toplev^.figtheta, toplev^.fdx, toplev^.fdy,
  931.               toplev^.fsx, toplev^.fsy);        
  932.          end;
  933.     Abeam : ;   (* not transformable *)
  934.  
  935.     Atieslur: ; (* not transformable *)
  936.  
  937.     Afigure : begin
  938.             toplevelxfm (toplev, pi, recurlevel + 1);
  939.           end;
  940.       end; (* case *)
  941.     end; (* with *)
  942.     pi := pi^.nextitem;
  943.     end;  (* while *)
  944.   if (recurlevel = 0) then
  945.     begin (* reset the toplevel's xfms *)
  946.     with toplev^ do
  947.       begin
  948.       figtheta := 0.0;
  949.       fsx := 1.0; fsy := 1.0;
  950.       fdx := 0;   fdy := 0;
  951.       end;    
  952.     end;
  953. end;
  954.  
  955.  
  956. {----------------------------------------------------------------}
  957. function scalefitfactor (actualwid, actualht, 
  958.              goalwid, goalht: ScaledPts): real;
  959. var sx, sy : real;
  960. begin
  961.   sx := goalwid/actualwid;
  962.   sy := goalht/actualht;
  963.   if (sx < sy) then
  964.     scalefitfactor := sx
  965.   else
  966.     scalefitfactor := sy;
  967. end;  
  968.  
  969.  
  970.  
  971. (* ---- The handlers for each primitive ---- 
  972.  *   The result of calling each handler is either immediate
  973.  *       output to the buffer of the commands to produce the
  974.  *       primitive, OR the primitive gets pushed onto a stack/list
  975.  *       that defines a current 'figure' (set of prims) for
  976.  *       output at a later time
  977.  *
  978.  *  Look at linehandle for a basic idea of how the handlers
  979.  *  work. the others follow pretty closely.
  980.  *)
  981.  
  982.  
  983. {------------------------------------------------------------}
  984. procedure linehandle (figdepth : integer; scalefact: real; 
  985.                      x1, y1, x2, y2 : ScaledPts;
  986.                      dvih, dviv : ScaledPts; (* possible dvi-offsets *)
  987.                      thk : VThickness; vk : VectKind;
  988.              patt : LineStyle;
  989.              minx, maxx, miny, maxy : ScaledPts;
  990.                      tx, ty: ScaledPts; sx, sy, r : real);
  991. var midx, midy : ScaledPts;                  
  992.     lineitem : pItem;
  993. begin
  994.    midx := (minx + maxx) div 2;
  995.    midy := (miny + maxy) div 2;
  996.  
  997.     (* do local primitive -level transformations *)
  998.    xfmlinepts (x1, y1, x2, y2, dvih, dviv,
  999.                 midx, midy, scalefact, r, tx, ty, sx, sy);
  1000.  
  1001.